perm filename TRNSPX.OLD[MSS,LCS] blob
sn#260744 filedate 1977-01-28 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE TRNSP(IT,ITR)
C00015 ENDMK
C⊗;
SUBROUTINE TRNSP(IT,ITR)
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
COMMON/STF/RSTFAC(-3/4),RSTJ2
1 /IPG/IPG,JPG,BRACK,RSTNUM(8),RPSZ(8),RHGT(8),RRCLEF(8)
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,ZCLEF,SIG,LB,SPG,MTR1,MTR2
1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,RNAM3
1 /LLL/LEND,NO1,NO2,NO3,XSIG /RSIG/RSIG(-3/4)
SLUR=0
PRX=99
MS=200
K=1
1002 IF(SIG.NE.-99)GO TO 499
C FOUND KSIG, SO DON'T DO THE REST
IF(XSIG.NE.0)GO TO 2002
RT=0
GO TO(94,94,93,92,92, 91,91,90,90,90, 97,97,96,96,95,
1 102,99,98),ITR
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb, 8↓, 8↑
102 RT=8
GO TO 41
95 RT=RT-1
96 RT=RT-1
97 RT=RT-1
GO TO 41
98 RT=7
GO TO 41
99 RT=-7
GO TO 41
94 RT=RT+1
93 RT=RT+1
92 RT=RT+1
91 RT=RT+1
90 RT=RT+1
41 TTR=AMOD(RT,7.0)
IF(TTR.EQ.0)GO TO 199
C WHAT DOES TTR DO???
IF(XSIG.NE.0)GO TO 199
NSIG=-1
TYPE 42
42 FORMAT(' ADD KEY SIG? -- ',$)
43 FORMAT(A1)
ACCEPT 43,XSIG
299 IF(XSIG.NE.'Y')GO TO 199
NSIG=0
C ***** NEXT FOR KEY SIG. ********
399 IADD=0
C ADD= ADD OR SUBTR. # OR b FROM KSIG.
GO TO (73,78,75,76,81, 72,79,74,77,399,
1 71,80,73,78,75, 74),ITR
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb, 8↓, 8↑
71 IADD=IADD+1
72 IADD=IADD+1
73 IADD=IADD+1
74 IADD=IADD+1
75 IADD=IADD+1
C 75=F, 81=G, 79=A, 73=E FLAT, 74=Bb, 80=D
GO TO 2002
76 IADD=IADD-1
77 IADD=IADD-1
78 IADD=IADD-1
79 IADD=IADD-1
80 IADD=IADD-1
81 IADD=IADD-1
2002 K=0
2003 R=0
RZ=RSIG(K)
IF(RZ.NE.-99)R=RZ
C??? RA=K
R=ADD+R
IF(RZ.EQ.-99)CALL STAFF
1 (4.,17.,4.0*RSTJ2,0,R,CLEF,0,0,0,0,0,0)
RSIG(K)=R
K=K+1
IF(K.LT.JPG)GO TO 2003
199 X=CODEN(KPN,K,Q,J)
IF(X.EQ.1)GO TO 1
IF(X.NE.3)GO TO 2
CLEF=Q(J+5)
IF(Q(J).LT.3)CLEF=0
IF(ITR.NE.3)GO TO 21
C NEXT FOR HORN IN F CLEF CHANGES
IF(CLEF.GE.100)CLEF=CLEF-100
C HORN CLEF CHANGES ARE KEPT, BS. CL'S ARE THROWN AWAY
21 IF(ITR.NE.16)GO TO 100
C NEXT FOR BASS CL. CLEF CHANGES.
IF(CLEF.NE.0)Q(J+5)=0
IF(CLEF.LT.100)GO TO 100
CC Q(J+1)=1089.
CALL SHRNK(K,IT)
C MAKE IT INVISIBLE IF IT WAS MINI.
CLEF=CLEF-100
GO TO 199
2 IF(X.NE.4)GO TO 20
BAR=-1
MS=200
GO TO 100
20 IF(X.NE.17)GO TO 12
C HOW ABOUT CHANGE TO NO SIG? OK, CODE =99
NSIG=0
12 IF(X.EQ.5)GO TO 120
IF(X.NE.6)GO TO 100
CC120 RT=TR
120 IF(RT.NE.8)GO TO 121
IF(CLEF.EQ.1)RT=-4
121 Q(J+4)=Q(J+4)+RT
Q(J+5)=Q(J+5)+RT
IF(X.EQ.5)SLUR=Q(J+6)
C SAVES RIGHT POS. OF SLUR
GO TO 100
C FOR BEAMS AND SLURS
C** IF(TR.NE.4)GO TO 21
C NEXT FOR HORN IN F CLEF CHANGES
C** IF(CLEF.GE.100)CLEF=CLEF-100
C HORN CLEF CHANGES ARE KEPT, BS. CL'S ARE THROWN AWAY
C**21 IF(TR.NE.8)GO TO 100
C NEXT FOR BASS CL. CLEF CHANGES.
C** IF(CLEF.LT.100)GO TO 100
C MAKE IT INVISIBLE IF IT WAS MINI.
C** CLEF=CLEF-100
C** GO TO 199
CS1000 RT=TR
1 R=Q(J+4)
RX=AMOD(R,100.0)
RZ=AMOD(RX,7.0)
C THE NOTE NUM
IF(RZ)RZ=RZ+7
C PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
R5=Q(J+5)
A=AMOD(R5,10.0)
C THE ACCI
RN(MS)=A
RN(MS+1)=RX
C SAVE FOR REPEATS
MS=MS+2
CHNAT=3
CS IF(MS.LT.4)GO TO 205
IF(MS.LT.203)GO TO 205
N=MS-3
200 IF(RX.NE.RN(N))GO TO 201
IF(A.EQ.0)GO TO 204
C NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
IF(A.EQ.RN(N-1))GO TO 204
GO TO 203
204 IF(RT.NE.8)GO TO 4
CC204 IF(TR.NE.8)GO TO 4
IF(CLEF.EQ.1)RT=RT-12
C FOR BSCLAR
GO TO 4
201 N=N-2
IF(N.GE.200)GO TO 200
205 IF(NSIG)CHNAT=0
203 ADD=A
C THE CHANGE IN ACCI
IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C FOUND CONNECTING TIE
CC IF(BAR.EQ.0)GO TO 204
C THIS ↑↑↑↑ ALWAYS PUTS ACCI AFTER A BAR -- EVEN WITH TIE------
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT. THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
IF(BAR)MS=200
GO TO 204
44 IF(NSIG)GO TO 440
IF(ITR.GE.16)GO TO 69
IF(A.EQ.0)GO TO 4
C ONLY CHECKS ON NOTES WITH NO ACCI
440 IF(CLEF.NE.1)GO TO 69
RZ=RZ-5
IF(RZ)RZ=RZ+7
69 GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53
1 ,64,65,66),ITR
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb, 8↓, 8↑
54 IF(RZ.EQ.3)GO TO 101
59 IF(RZ.EQ.6)GO TO 101
52 IF(RZ.EQ.2)GO TO 101
57 IF(RZ.EQ.5)GO TO 101
C FOR "A". FINDS C,F AND G.
62 IF(RZ.EQ.1)GO TO 101
55 IF(RZ.EQ.4)GO TO 101
C "G" F→Bb, F#→B NAT.
GO TO 4
61 IF(RZ.EQ.5)GO TO 7
56 IF(RZ.EQ.2)GO TO 7
63 IF(RZ.EQ.6)GO TO 7
58 IF(RZ.EQ.3)GO TO 7
53 IF(RZ.NE.0)GO TO 4
7 IF(A.EQ.0)GO TO 402
IF(A.EQ.3)GO TO 402
C CHNG NO ACCI OR NAT TO SHARP
IF(A.EQ.4)GO TO 401
C 4=bb 5=##
IF(A.EQ.2)GO TO 405
C NEXT FOR B#, E#
CC RT=RT+1
C MOVE IT UP A STEP
30 ADD=CHNAT
C MAKE IT NAT. IF NEEDED
3 Q(J+5)=R5-A+ADD
4 PRX=RX
C REAL NOTE LEVEL
Q(J+4)=R+RT
BAR=0
100 IF(K.GE.IT)GO TO 499
K=K+1
GO TO 199
65 RT=RT-7
GO TO 4
66 RT=RT+8
GO TO 4
C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
64 IF(CLEF.EQ.1)RT=RT-12
GO TO 58
101 IF(A.EQ.0)GO TO 401
IF(A.EQ.2)GO TO 30
IF(A.EQ.3)GO TO 401
IF(A.EQ.5)GO TO 402
C WON'T HANDLE Gbb→Ab
404 ADD=4
GO TO 3
401 ADD=1
GO TO 3
402 ADD=2
GO TO 3
405 ADD=5
GO TO 3
499 CALL RVRS(IT)
C TO REVERSE STEMS, BEAMS AND SLURS
END
SUBROUTINE RVRS(IT)
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
K=1
1 J=KPN(K)
R=Q(J+1)
IF(R.NE.1)GO TO 2
C JUMP IF NOT A NOTE
IF(Q(J+5).LT.10)GO TO 10
C JUMP IF NO STEM ON IT
KK=K+1
3 IF(KK.GT.IT)RETURN
JJ=KPN(KK)
RR=Q(JJ+1)
IF(RR.NE.1)GO TO 5
C JUMP IF NOT A NOTE
IF(Q(JJ+5).GE.10)GO TO 6
C SKIP CHORD NOTES (NO STEM)
7 KK=KK+1
GO TO 3
C DID NOT FIND BEAM NEARBY
6 RZ=AMOD(Q(J+4),100.0)
N=J+5
A=10
IF(RZ.GE.7)GO TO 60
IF(Q(N).LT.20)GO TO 10
C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
A=-A
GO TO 15
60 IF(Q(N).GE.20)GO TO 10
C THERE MUST BE A BETTER WAY!
15 Q(N)=Q(N)+A
GO TO 10
8 IF(Q(N).LT.20)GO TO 10
A=-A
C STEM UP
GO TO 15
5 IF(RR.NE.6)GO TO 6
20 B=Q(JJ+4)
C=Q(JJ+5)
D=(B+C)/2.
IF(RR.EQ.5)GO TO 9
IF(RR.NE.6)GO TO 10
B=Q(JJ+6)+1.
C SAVES RANGE OF BEAM +1.
IF(Q(JJ+7).GE.20)GO TO 11
C NOW STEMS ARE UP
IF(D.LT.7)GO TO 12
C JUMP TO 12 IF ALL OK
CC C=-10
JSTM=0
C SAVE FOR REVERSED STEMS
GO TO 23
11 IF(D.GE.7.)GO TO 12
C STEMS DOWN
C JUMP IF NO REVERSE NEEDED
JSTM=-1
23 JH=0
CHNG=0
DO 16 N=K,IT
KK=KPN(N)
IF(Q(KK+3).GT.B)GO TO 140
R=Q(KK+1)
IF(R.NE.1)GO TO 17
L=5
R=Q(KK+8)
C THE STEM LENGTH
IF(R.EQ.999)R=0
Q(KK+8)=-R
C FOR THE INVERSION
19 C=10.
A=Q(KK+L)
IF(A.GE.20)C=-C
Q(KK+L)=C+A
IF(JH.NE.0)GO TO 161
C NEXT FOR 1ST NOTE UNDER BEAM
JH=4
160 R=Q(JJ+JH)-Q(KK+4)
C=-1
IF(JSTM)GO TO 163
C=R
R=1
C NOW STEMS UP
163 IF(R.GT.C)GO TO 162
C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
CHNG=C-R
IF(JSTM.EQ.0)CHNG=-CHNG
JH=JJ+4
Q(JH)=Q(JH)+CHNG
JH=JH+1
Q(JH)=Q(JH)+CHNG
162 IF(L)GO TO 141
C FOR ESCAPE FROM LOOP
161 JH=KK
C JH SAVES PTR TO LAST NOTE UNDER BEAM
GO TO 16
17 IF(R.NE.6)GO TO 18
C NOW IT'S A BEAM
L=7
GO TO 19
18 IF(R.NE.5)GO TO 16
C NOW IT'S A SLUR
C=-4
IF(Q(KK+7))C=-C
CALL SLRV(KK,C)
C TO REVERSE SLUR
CC Q(KK+7)=-Q(KK+7)
16 CONTINUE
C SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
140 KK=JH
L=-1
JH=5
C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
GO TO 160
141 IF(CHNG.EQ.0)GO TO 14
IF(CHNG)CHNG=-CHNG
DO 142 N=K,IT
C TO READJUST STEMS UNDER REVERSED BEAMS
KK=KPN(N)
IF(Q(KK+3).GT.B)GO TO 14
IF(Q(KK+1).NE.1)GO TO 142
Q(KK+8)=Q(KK+8)+CHNG
C THE STEM LENGTH
142 CONTINUE
GO TO 14
C NEXT FOR SLURS
9 B=-4
IF(Q(JJ+7))GO TO 24
IF(D.GT.7)GO TO 10
C JUMP TO LEAVE STEM UP
GO TO 25
24 IF(D.LT.5)GO TO 10
C JUMP TO LEAVE STEM DOWN
B=-B
CC25 Q(JJ+4)=Q(JJ+4)+B
CC Q(JJ+5)=Q(JJ+5)+B
CC Q(JJ+7)=-R
25 CALL SLRV(JJ,B)
GO TO 10
12 DO 13 N=K+1,IT
KK=KPN(N)
13 IF(Q(KK+3).GT.B)GO TO 14
C JUMP OUT WHEN PAST END OF BEAM.
14 K=N-1
GO TO 10
2 IF(R.NE.6)GO TO 21
22 JJ=J
RR=R
GO TO 20
21 IF(R.EQ.5)GO TO 22
10 IF(K.GT.IT)RETURN
K=K+1
GO TO 1
END